home *** CD-ROM | disk | FTP | other *** search
/ Night Owl 6 / Night Owl's Shareware - PDSI-006 - Night Owl Corp (1990).iso / 016a / gofer221.zip / OUTPUT.C < prev    next >
C/C++ Source or Header  |  1991-11-20  |  16KB  |  632 lines
  1. /* --------------------------------------------------------------------------
  2.  * output.c:    Copyright (c) Mark P Jones 1991.   All rights reserved.
  3.  *        See goferite.h for details and conditions of use etc...
  4.  *        Gofer version 2.21 November 1991
  5.  *
  6.  *        Last updated 03/11/91 mpj
  7.  *
  8.  * Unparse expressions and types - for use in error messages, type checker
  9.  * and for debugging.
  10.  * ------------------------------------------------------------------------*/
  11.  
  12. #include "prelude.h"
  13. #include "storage.h"
  14. #include "connect.h"
  15. #include "errors.h"
  16. #include <ctype.h>
  17.  
  18. /* --------------------------------------------------------------------------
  19.  * Local function prototypes:
  20.  * ------------------------------------------------------------------------*/
  21.  
  22. static Void local put             Args((Int,Cell));
  23. static Void local putQual        Args((Cell));
  24. static Bool local isDictVal     Args((Cell));
  25. static Cell local maySkipDict     Args((Cell));
  26. static Void local putAp         Args((Int,Cell));
  27. static Void local putOverInfix   Args((Int,Text,Syntax,Cell));
  28. static Void local putInfix     Args((Int,Text,Syntax,Cell,Cell));
  29. static Void local putSimpleAp     Args((Cell));
  30. static Void local putTuple     Args((Int,Cell));
  31. static Int  local unusedTups     Args((Int,Cell));
  32. static Void local unlexVar     Args((Text));
  33. static Void local unlexOp     Args((Text));
  34. static Void local unlexCharConst Args((Cell));
  35. static Void local unlexStrConst     Args((Text));
  36.  
  37. static Void local putSigType     Args((Cell));
  38. static Void local putContext     Args((List));
  39. static Void local putPred     Args((Cell));
  40. static Void local putType     Args((Cell,Int));
  41. static Bool local putTupleType   Args((Cell));
  42. static Void local putConType     Args((Cell));
  43.  
  44. /* --------------------------------------------------------------------------
  45.  * Basic output routines:
  46.  * ------------------------------------------------------------------------*/
  47.  
  48. static FILE *outputStream;
  49. Bool   showDicts = TRUE;        /* TRUE => include dictionary vars */
  50.                     /*       in output expressions   */
  51.  
  52. #define OPEN(b)    if (b) putChr('(');
  53. #define CLOSE(b)   if (b) putChr(')');
  54.  
  55. #define putChr(c)  fputc(c,outputStream)
  56. #define putInt(n)  fprintf(outputStream,"%d",n)
  57. #define putStr(m)  fprintf(outputStream,"%s",m)
  58.  
  59. /* --------------------------------------------------------------------------
  60.  * Precedence values (See Haskell report p.10):
  61.  * ------------------------------------------------------------------------*/
  62.  
  63. #define ALWAYS        FUN_PREC           /* Always use parens (unless atomic)*/
  64.                        /* User defined operators have prec */
  65.                        /* in the range MIN_PREC..MAX_PREC  */
  66. #define ARROW_PREC  MAX_PREC           /* for printing -> in type exprs    */
  67. #define COCO_PREC   (MIN_PREC-1)       /* :: is left assoc, low precedence */
  68. #define COND_PREC   (MIN_PREC-2)       /* conditional expressions       */
  69. #define WHERE_PREC  (MIN_PREC-3)       /* where expressions           */
  70. #define LAM_PREC    (MIN_PREC-4)       /* lambda abstraction           */
  71. #define NEVER        LAM_PREC           /* Never use parentheses        */
  72.  
  73.  
  74. /* --------------------------------------------------------------------------
  75.  * Print an expression (used to display context of type errors):
  76.  * ------------------------------------------------------------------------*/
  77.  
  78. static Void local put(d,e)           /* print expression e in context of */
  79. Int  d;                    /* operator of precedence d       */
  80. Cell e; {
  81.     List xs;
  82.  
  83.     switch (whatIs(e)) {
  84.     case FINLIST    : putChr('[');
  85.               xs = snd(e);
  86.               if (nonNull(xs)) {
  87.                   put(NEVER,hd(xs));
  88.                   while (nonNull(xs=tl(xs))) {
  89.                   putChr(',');
  90.                   put(NEVER,hd(xs));
  91.                   }
  92.               }
  93.               putChr(']');
  94.               break;
  95.  
  96.     case AP     : putAp(d,e);
  97.               break;
  98.  
  99.     case NAME    : unlexVar(name(e).text);
  100.               break;
  101.  
  102.     case VARIDCELL    :
  103.     case VAROPCELL    :
  104.     case DICTVAR    :
  105.     case CONIDCELL    :
  106.     case CONOPCELL    : unlexVar(textOf(e));
  107.               break;
  108.  
  109.     case DICTCELL   : putStr("{dict}");
  110.               break;
  111.  
  112.     case SELECT    : putStr("#");
  113.               putInt(selectOf(e));
  114.               break;
  115.  
  116.     case UNIT    : putStr("()");
  117.               break;
  118.  
  119.     case TUPLE    : putTuple(tupleOf(e),e);
  120.               break;
  121.  
  122.     case WILDCARD    : putChr('_');
  123.               break;
  124.  
  125.     case ASPAT    : put(NEVER,fst(snd(e)));
  126.               putChr('@');
  127.               put(ALWAYS,snd(snd(e)));
  128.               break;
  129.  
  130.     case LAZYPAT    : putChr('~');
  131.               put(ALWAYS,snd(e));
  132.               break;
  133.  
  134.     case LISTCOMP    : putStr("[ ");
  135.               put(NEVER,fst(snd(e)));
  136.               putStr(" | ");
  137.               xs = snd(snd(e));
  138.               if (nonNull(xs)) {
  139.                   putQual(hd(xs));
  140.                   while (nonNull(xs=tl(xs))) {
  141.                   putStr(", ");
  142.                   putQual(hd(xs));
  143.                   }
  144.               }
  145.               putChr(']');
  146.               break;
  147.  
  148.     case CHARCELL    : unlexCharConst(charOf(e));
  149.               break;
  150.  
  151.     case INTCELL    : putInt(intOf(e));
  152.               break;
  153.  
  154.         case FLOATCELL  : putStr(floatToString(floatOf(e)));
  155.               break;
  156.  
  157.     case STRCELL    : unlexStrConst(textOf(e));
  158.               break;
  159.  
  160.     case LETREC    : OPEN(d>WHERE_PREC);
  161. #ifdef DEBUG_CODE
  162.               putStr("let {");
  163.               put(NEVER,fst(snd(e)));
  164.               putStr("} in ");
  165. #else
  166.                           putStr("let {...} in ");
  167. #endif
  168.                           put(WHERE_PREC+1,snd(snd(e)));
  169.               CLOSE(d>WHERE_PREC);
  170.               break;
  171.  
  172.     case COND    : OPEN(d>COND_PREC);
  173.               putStr("if ");
  174.               put(COND_PREC+1,fst3(snd(e)));
  175.               putStr(" then ");
  176.               put(COND_PREC+1,snd3(snd(e)));
  177.               putStr(" else ");
  178.               put(COND_PREC+1,thd3(snd(e)));
  179.               CLOSE(d>COND_PREC);
  180.               break;
  181.  
  182.     case LAMBDA    : xs = fst(snd(e));
  183.               if (!showDicts) {
  184.                   while (nonNull(xs) && isDictVal(hd(xs)))
  185.                   xs = tl(xs);
  186.                   if (isNull(xs)) {
  187.                   put(d,snd(snd(snd(e))));
  188.                   break;
  189.                   }
  190.               }
  191.               OPEN(d>LAM_PREC);
  192.               putChr('\\');
  193.               if (nonNull(xs)) {
  194.                   put(ALWAYS,hd(xs));
  195.                   while (nonNull(xs=tl(xs))) {
  196.                   putChr(' ');
  197.                   put(ALWAYS,hd(xs));
  198.                   }
  199.               }
  200.               putStr(" -> ");
  201.               put(LAM_PREC,snd(snd(snd(e))));
  202.               CLOSE(d>LAM_PREC);
  203.               break;
  204.  
  205.     case ESIGN    : OPEN(d>COCO_PREC);
  206.               put(COCO_PREC,fst(snd(e)));
  207.               putStr(" :: ");
  208.               putSigType(snd(snd(e)));
  209.               CLOSE(d>COCO_PREC);
  210.               break;
  211.  
  212.     case CASE    : putStr("case ");
  213.               put(NEVER,fst(snd(e)));
  214. #ifdef DEBUG_CODE
  215.               putStr(" of {");
  216.               put(NEVER,snd(snd(e)));
  217.               putChr('}');
  218. #else
  219.               putStr(" of {...}");
  220. #endif
  221.               break;
  222.  
  223.     case INDIRECT    : putChr('^');
  224.               put(ALWAYS,snd(e));
  225.               break;
  226.  
  227.     default     : /*internal("put");*/
  228.               putChr('$');
  229.               putInt(e);
  230.               break;
  231.     }
  232. }
  233.  
  234. static Void local putQual(q)           /* print list comp qualifier       */
  235. Cell q; {
  236.     switch (whatIs(q)) {
  237.     case BOOLQUAL : put(NEVER,snd(q));
  238.             return;
  239.  
  240.     case QWHERE   : put(ALWAYS,fst(snd(q)));
  241.             putChr('=');
  242.             put(NEVER,snd(snd(q)));
  243.             return;
  244.  
  245.     case FROMQUAL : put(ALWAYS,fst(snd(q)));
  246.             putStr("<-");
  247.             put(NEVER,snd(snd(q)));
  248.             return;
  249.     }
  250. }
  251.  
  252. static Bool local isDictVal(e)        /* Look for dictionary value       */
  253. Cell e; {
  254.     switch (whatIs(e)) {
  255.     case AP          : return isSelect(fun(e));
  256.     case DICTCELL :
  257.     case DICTVAR  : return TRUE;
  258.     }
  259.     return FALSE;
  260. }
  261.  
  262. static Cell local maySkipDict(e)    /* descend function application       */
  263. Cell e; {                /* possibly ignoring dict aps       */
  264.     if (!showDicts)
  265.     while (isAp(e) && isDictVal(arg(e)))
  266.         e = fun(e);
  267.     return e;
  268. }
  269.  
  270. static Void local putAp(d,e)        /* print application (args>=1)       */
  271. Int  d;
  272. Cell e; {
  273.     Bool   anyDictArgs = FALSE;
  274.     Cell   h;
  275.     Text   t;
  276.     Syntax sy;
  277.     Int    args = 0;
  278.  
  279.     for (h=e; isAp(h); h=fun(h))    /* find head of expression, looking*/
  280.     if (isDictVal(arg(h))) {    /* for dictionary arguments       */
  281.         anyDictArgs = TRUE;
  282.         if (showDicts)
  283.         args++;
  284.     }
  285.     else
  286.         args++;
  287.  
  288.     if (args==0) {            /* Special case when *all* args       */
  289.     put(d,h);            /* are dictionary values       */
  290.     return;
  291.     }
  292.  
  293.     switch (whatIs(h)) {
  294.     case ADDPAT    : if (args==1)
  295.                   putInfix(d,textPlus,syntaxOf(textPlus),
  296.                      arg(e),mkInt(intValOf(fun(e))));
  297.               else
  298.                   putStr("ADDPAT");
  299.               return;
  300.  
  301.     case MULPAT    : if (args==1)
  302.                   putInfix(d,textMult,syntaxOf(textMult),
  303.                      mkInt(intValOf(fun(e))),arg(e));
  304.               else
  305.                   putStr("MULPAT");
  306.               return;
  307.  
  308.     case TUPLE    : OPEN(args>tupleOf(h) && d>=FUN_PREC);
  309.               putTuple(tupleOf(h),e);
  310.               CLOSE(args>tupleOf(h) && d>=FUN_PREC);
  311.               return;
  312.  
  313.     case NAME    : sy = syntaxOf(t = name(h).text);
  314.               break;
  315.     case VARIDCELL    :
  316.     case VAROPCELL    :
  317.     case DICTVAR    :
  318.     case CONIDCELL    :
  319.     case CONOPCELL    : sy = syntaxOf(t = textOf(h));
  320.               break;
  321.  
  322.     default     : sy = APPLIC;
  323.               break;
  324.     }
  325.  
  326.     e = maySkipDict(e);
  327.     if (showDicts && anyDictArgs)    /* expressions involving dicts       */
  328.     sy = APPLIC;            /* are printed applicatively       */
  329.  
  330.     if (sy==APPLIC) {                   /* print simple application       */
  331.     OPEN(d>=FUN_PREC);
  332.     putSimpleAp(e);
  333.     CLOSE(d>=FUN_PREC);
  334.     return;
  335.     }
  336.     else if (args==1) {                /* print section of the form (e+)  */
  337.     putChr('(');
  338.     put(FUN_PREC-1,arg(e));
  339.     putChr(' ');
  340.     unlexOp(t);
  341.     putChr(')');
  342.     }
  343.     else if (args==2)               /* infix expr of the form e1 + e2   */
  344.     putInfix(d,t,sy,arg(maySkipDict(fun(e))),arg(e));
  345.     else {                   /* o/w (e1 + e2) e3 ... en   (n>=3) */
  346.     OPEN(d>=FUN_PREC);
  347.     putOverInfix(args,t,sy,e);
  348.     CLOSE(d>=FUN_PREC);
  349.     }
  350. }
  351.  
  352. static Void local putOverInfix(args,t,sy,e)
  353. Int    args;                   /* infix applied to >= 3 arguments  */
  354. Text   t;
  355. Syntax sy;
  356. Cell   e; {
  357.     if (args>2) {
  358.     putOverInfix(args-1,t,sy,maySkipDict(fun(e)));
  359.     putChr(' ');
  360.     put(FUN_PREC,arg(e));
  361.     }
  362.     else
  363.     putInfix(ALWAYS,t,sy,arg(maySkipDict(fun(e))),arg(e));
  364. }
  365.  
  366. static Void local putInfix(d,t,sy,e,f)  /* print infix expression       */
  367. Int    d;
  368. Text   t;                /* Infix operator symbol         */
  369. Syntax sy;                /* with name t, syntax s        */
  370. Cell   e, f; {                /* Left and right operands       */
  371.     Syntax a = assocOf(sy);
  372.     Int    p = precOf(sy);
  373.  
  374.     OPEN(d>p);
  375.     put((a==LEFT_ASS ? p : 1+p), e);
  376.     putChr(' ');
  377.     unlexOp(t);
  378.     putChr(' ');
  379.     put((a==RIGHT_ASS ? p : 1+p), f);
  380.     CLOSE(d>p);
  381. }
  382.  
  383. static Void local putSimpleAp(e)       /* print application e0 e1 ... en   */
  384. Cell e; {
  385.     if (isAp(e)) {
  386.     putSimpleAp(maySkipDict(fun(e)));
  387.     putChr(' ');
  388.     put(FUN_PREC,arg(e));
  389.     }
  390.     else
  391.     put(FUN_PREC,e);
  392. }
  393.  
  394. static Void local putTuple(ts,e)    /* Print tuple expression, allowing*/
  395. Int  ts;                /* for possibility of either too   */
  396. Cell e; {                /* few or too many args to constr  */
  397.     Int i;
  398.     putChr('(');
  399.     if ((i=unusedTups(ts,e))>0) {
  400.     while (--i>0)
  401.         putChr(',');
  402.         putChr(')');
  403.     }
  404. }
  405.  
  406. static Int local unusedTups(ts,e)    /* print first part of tuple expr  */
  407. Int  ts;                /* returning number of constructor */
  408. Cell e; {                /* args not yet printed ...       */
  409.     if (isAp(e)) {
  410.     if ((ts=unusedTups(ts,fun(e))-1)>=0) {
  411.         put(NEVER,arg(e));
  412.         putChr(ts>0?',':')');
  413.     }
  414.     else {
  415.         putChr(' ');
  416.         put(FUN_PREC,arg(e));
  417.     }
  418.     }
  419.     return ts;
  420. }
  421.  
  422. static Void local unlexVar(t)           /* print text as a variable name    */
  423. Text t; {                   /* operator symbols must be enclosed*/
  424.     String s = textToStr(t);           /* in parentheses... except [] ...  */
  425.  
  426.     if ((isascii(s[0]) && isalpha(s[0])) || s[0]=='_' || strcmp(s,"[]")==0)
  427.     putStr(s);
  428.     else {
  429.     putChr('(');
  430.     putStr(s);
  431.     putChr(')');
  432.     }
  433. }
  434.  
  435. static Void local unlexOp(t)           /* print text as operator name       */
  436. Text t; {                   /* alpha numeric symbols must be    */
  437.     String s = textToStr(t);           /* enclosed by backquotes       */
  438.  
  439.     if (isascii(s[0]) && isalpha(s[0])) {
  440.     putChr('`');
  441.     putStr(s);
  442.     putChr('`');
  443.     }
  444.     else
  445.     putStr(s);
  446. }
  447.  
  448. static Void local unlexCharConst(c)
  449. Cell c; {
  450.     putChr('\'');
  451.     putStr(unlexChar(c,'\''));
  452.     putChr('\'');
  453. }
  454.  
  455. static Void local unlexStrConst(t)
  456. Text t; {
  457.     String s            = textToStr(t);
  458.     static Char SO      = 14;        /* ASCII code for '\SO'           */
  459.     Bool   lastWasSO    = FALSE;
  460.     Bool   lastWasDigit = FALSE;
  461.     Bool   lastWasEsc   = FALSE;
  462.  
  463.     putChr('\"');
  464.     for (; *s; s++) {
  465.         String ch = unlexChar(*s,'\"');
  466.     Char   c  = ' ';
  467.  
  468.     if ((lastWasSO && *ch=='H') ||
  469.         (lastWasEsc && lastWasDigit && isascii(*ch) && isdigit(*ch)))
  470.         putStr("\\&");
  471.  
  472.         lastWasEsc   = (*ch=='\\');
  473.         lastWasSO    = (*s==SO);
  474.         for (; *ch; c = *ch++)
  475.         putChr(*ch);
  476.         lastWasDigit = (isascii(c) && isdigit(c));
  477.     }
  478.     putChr('\"');
  479. }
  480.  
  481. /* --------------------------------------------------------------------------
  482.  * Print type expression:
  483.  * ------------------------------------------------------------------------*/
  484.  
  485. static Void local putSigType(t)        /* print (possibly) generic type   */
  486. Cell t; {
  487.     if (isPolyType(t))            /* skip (forall _) part (if any)   */
  488.         t = snd(t);
  489.  
  490.     if (whatIs(t)==QUAL) {        /* Handle qualified types          */
  491.         putContext(fst(snd(t)));
  492.         putStr(" => ");
  493.         t = snd(snd(t));
  494.     }
  495.  
  496.     putType(t,NEVER);            /* Finally, print rest of type ... */
  497. }
  498.  
  499. static Void local putContext(qs)    /* print context list           */
  500. List qs; {
  501.     if (isNull(qs))
  502.     putStr("()");
  503.     else {
  504.     Int nq = length(qs);
  505.  
  506.     if (nq!=1) putChr('(');
  507.     putPred(hd(qs));
  508.     while (nonNull(qs=tl(qs))) {
  509.         putStr(", ");
  510.         putPred(hd(qs));
  511.     }
  512.     if (nq!=1) putChr(')');
  513.     }
  514. }
  515.  
  516. static Void local putPred(pi)        /* Output predicate           */
  517. Cell pi; {
  518.     if (isAp(pi)) {
  519.     putPred(fun(pi));
  520.     putChr(' ');
  521.     putType(arg(pi),ALWAYS);
  522.     }
  523.     else if (isClass(pi))
  524.     putStr(textToStr(class(pi).text));
  525.     else if (isCon(pi))
  526.     putStr(textToStr(textOf(pi)));
  527.     else
  528.     putStr("<unknownPredicate>");
  529. }
  530.  
  531. static Void local putType(t,prec)    /* print nongeneric type expression*/
  532. Cell t;
  533. Int  prec; {
  534.     Cell typeHead=getHead(t);
  535.  
  536.     switch(whatIs(typeHead)) {
  537.     case UNIT    : putStr("()");
  538.                return;
  539.  
  540.     case TUPLE   : putChr('(');
  541.                putTupleType(t);
  542.                putChr(')');
  543.                break;
  544.  
  545.     case LIST    : putChr('[');
  546.                putType(arg(t),NEVER);
  547.                putChr(']');
  548.                break;
  549.  
  550.     case OFFSET:   putChr('a'+offsetOf(typeHead));
  551.                break;
  552.  
  553.     case INTCELL : putChr('_');
  554.                putInt(intOf(t));
  555.                break;
  556.  
  557.     case TYCON   : {   Bool brackets = (argCount!=0 && prec>=ALWAYS);
  558.                            OPEN(brackets);
  559.                            putConType(t);
  560.                            CLOSE(brackets);
  561.                        }
  562.                        break;
  563.  
  564.     case ARROW   : OPEN(prec>=ARROW_PREC);
  565.                putType(arg(fun(t)),ARROW_PREC);
  566.                putStr(" -> ");
  567.                putType(arg(t),NEVER);
  568.                CLOSE(prec>=ARROW_PREC);
  569.                break;
  570.  
  571.     default      : putStr("(bad type)");
  572.     }
  573. }
  574.  
  575. static Bool local putTupleType(e)    /* print tuple of types, returning */
  576. Cell e; {                /* TRUE if something was printed,  */
  577.     if (isAp(e)) {            /* FALSE otherwise; used to control*/
  578.     if (putTupleType(fun(e)))    /* printing of intermed. commas       */
  579.         putChr(',');
  580.     putType(arg(e),NEVER);
  581.     return TRUE;
  582.     }
  583.     return FALSE;
  584. }
  585.  
  586. static Void local putConType(t)        /* print type of form Tycon t1...tn*/
  587. Cell t; {
  588.     if (isAp(t)) {
  589.     putConType(fun(t));
  590.     putChr(' ');
  591.     putType(arg(t),ALWAYS);
  592.     }
  593.     else if (isTycon(t))
  594.     putStr(textToStr(tycon(t).text));
  595.     else
  596.     putStr("(bad type)");
  597. }
  598.  
  599. /* --------------------------------------------------------------------------
  600.  * Main drivers:
  601.  * ------------------------------------------------------------------------*/
  602.  
  603. Void printExp(fp,e)            /* print expr on specified stream  */
  604. FILE *fp;
  605. Cell e; {
  606.     outputStream = fp;
  607.     put(NEVER,e);
  608. }
  609.  
  610. Void printType(fp,t)            /* print type on specified stream  */
  611. FILE *fp;
  612. Cell t; {
  613.     outputStream = fp;
  614.     putSigType(t);
  615. }
  616.  
  617. Void printContext(fp,qs)        /* print context on spec. stream   */
  618. FILE *fp;
  619. List qs; {
  620.     outputStream = fp;
  621.     putContext(qs);
  622. }
  623.  
  624. Void printPred(fp,pi)            /* print predicate pi on stream    */
  625. FILE  *fp;
  626. Cell  pi; {
  627.     outputStream = fp;
  628.     putPred(pi);
  629. }
  630.  
  631. /*-------------------------------------------------------------------------*/
  632.